home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / EXPAND2.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  45KB  |  1,466 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #define GEN
  10.  
  11. #include "hdr.h"
  12. #include "libhdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "gmainp.h"
  17. #include "setp.h"
  18. #include "miscp.h"
  19. #include "gnodesp.h"
  20. #include "gutilp.h"
  21. #include "gmiscp.h"
  22. #include "initobjp.h"
  23. #include "arithp.h"
  24. #include "chapp.h"
  25. #include "smiscp.h"
  26. #include "expandp.h"
  27.  
  28. static Tuple constrained_type(Symbol, Node, Node);
  29. static int array_nelem(Node);
  30. static void replace_name(Node, Symbol, Symbol);
  31.  
  32. static int array_nelem_defined; /* set if array_nelem undefined */
  33.  
  34. void expand_line()                                            /*;expand_line*/
  35. {
  36.     /* called when expander reaches line debug_line if debug_line is not
  37.      * zero. This is meant to provide useful trapping point for
  38.      * interactive debugging.        ds 7-19-85
  39.      */
  40. }
  41.  
  42.  
  43. int in_bin_ops(Symbol op)                                    /*;in_bin_ops*/
  44. {
  45.     /*     bin_ops = {'and',  'or',  'xor', '&', '&ac', '&ca', &cc'
  46.      *     '=',    '/=',  '<=',  '>',    '>=',   '<',     
  47.      *     '+i',   '-i',   '*i',  '/i',  '**i',  'remi', 'modi', 
  48.      *     '+fl',   '-fl',  '*fl', '/fl', '**fl', 
  49.      *     '+fx',   '-fx',  '*fx', '/fx', '*fix', '*fxi', '/fxi'},
  50.      */
  51.     return op == symbol_and || op == symbol_or || op == symbol_xor 
  52.       || op == symbol_cat || op == symbol_cat_cc || op == symbol_cat_ca
  53.       || op == symbol_cat_ac || op == symbol_eq || op == symbol_ne
  54.       || op == symbol_le || op == symbol_gt || op == symbol_ge
  55.       || op == symbol_lt || op == symbol_addi || op == symbol_subi
  56.       || op == symbol_muli || op == symbol_divi || op == symbol_expi 
  57.       || op == symbol_remi || op == symbol_modi || op == symbol_addfl
  58.       ||op == symbol_subfl || op == symbol_mulfl || op == symbol_divfl
  59.       || op == symbol_expfl || op == symbol_addfx || op == symbol_subfx
  60.       || op == symbol_mulfx || op == symbol_divfx || op == symbol_mulfix
  61.       || op == symbol_mulfxi || op == symbol_divfxi;
  62. }
  63.  
  64. int in_un_ops(Symbol op)                                    /*;in_un_ops*/
  65. {
  66.     /*    un_ops =  {'not', '-ui',  '+ui',  'absi', '-ufl', '+ufl', 'absfl',
  67.      *    '-ufx', '+ufx', 'absfx'  };
  68.      */
  69.  
  70.     return op == symbol_not || op == symbol_subui || op == symbol_addui
  71.       || op == symbol_absi || op == symbol_subufl || op == symbol_addufl
  72.       || op == symbol_absfl || op == symbol_subufx || op == symbol_addufx
  73.       || op == symbol_absfx;
  74. }
  75.  
  76. void expand_block(Node decl_node, Node stmt_node, Node exc_node, Node term_node)
  77.                                                             /*;expand_block*/
  78. {
  79.     Node    stmt_list_node;
  80.  
  81.     if (decl_node != OPT_NODE)
  82.         expand(decl_node);
  83.  
  84.     stmt_list_node = N_AST1(stmt_node);
  85.     N_LIST(stmt_list_node) = tup_with(N_LIST(stmt_list_node),
  86.       (char *) copy_tree(term_node));
  87.     expand(stmt_node);
  88.  
  89.     if (exc_node != OPT_NODE) {
  90.         /* Note: exc node may be a sequence of statements */
  91.         if (N_KIND(exc_node) == as_exception) {
  92.             N_AST1(exc_node) = term_node;
  93.             if (N_AST2_DEFINED(as_exception)) N_AST2(exc_node) = (Node) 0;
  94.             if (N_AST3_DEFINED(as_exception)) N_AST3(exc_node) = (Node) 0;
  95.             if (N_AST4_DEFINED(as_exception)) N_AST4(exc_node) = (Node) 0;
  96.         }
  97.         expand(exc_node);
  98.     }
  99. }
  100.  
  101. static Tuple constrained_type(Symbol array_type, Node lbd_node, Node ubd_node)
  102.                                                         /*;constrained_type*/
  103. {
  104.     /*
  105.      * Given an unconstrained array type, constructs a constrained subtype
  106.      * with the given bounds.
  107.      * returns [type_name, decls] where type_name is the name of the
  108.      * constrained array subtype, and decls a list (tuple) of nodes necessary
  109.      * to elaborate the type.
  110.      */
  111.  
  112.     Symbol   bt, index_name, array_name, comp_type;
  113.     Node    range_node, indic_node, ix_name_node, index_node, ar_name_node,
  114.       array_node;
  115.     Tuple    tup, dtup;
  116.  
  117.     bt = base_type(N_TYPE(lbd_node));
  118.  
  119.     /* 1- Create range node */
  120.     range_node        = node_new(as_range);
  121.     N_AST1(range_node) = lbd_node;
  122.     N_AST2(range_node) = ubd_node;
  123.     indic_node        = node_new(as_subtype_indic);
  124.     N_AST1(indic_node) = new_name_node(bt);
  125.     N_AST2(indic_node) = range_node;
  126.  
  127.     /* 2- Create index subtype */
  128.     index_name         = new_unique_name("index");
  129.     ix_name_node       = new_name_node(index_name);
  130.     index_node         = node_new(as_subtype_decl);
  131.     N_AST1(index_node) = ix_name_node;
  132.     N_AST2(index_node) = indic_node;
  133.     tup = constraint_new(co_range);
  134.     tup[2] = (char *) lbd_node;
  135.     tup[3] = (char *) ubd_node;
  136.     new_symbol(index_name, na_subtype, bt, tup, ALIAS(bt));
  137.     CONTAINS_TASK(index_name) = FALSE;
  138.  
  139.     /* 3- Create constrained array subtype */
  140.     indic_node         = node_new(as_constraint);
  141.     N_LIST(indic_node) = tup_new1( (char *) new_name_node(index_name));
  142.     array_name         = new_unique_name("array");
  143.     ar_name_node       = new_name_node(array_name);
  144.     array_node         = node_new(as_subtype_decl);
  145.     N_AST1(array_node)  = ar_name_node;
  146.     N_AST2(array_node)  = indic_node;
  147.     comp_type = (Symbol) (SIGNATURE(array_type))[2];
  148.     tup = tup_new(2);
  149.     tup[1] = (char *) tup_new1( (char *) index_name);
  150.     tup[2] = (char *) comp_type;
  151.     new_symbol(array_name, na_subtype, array_type,
  152.       tup, ALIAS(array_type));
  153.     CONTAINS_TASK(array_name) = CONTAINS_TASK(array_type);
  154.     dtup = tup_new(2);
  155.     dtup[1] = (char *) index_node;
  156.     dtup[2] = (char *) array_node;
  157.     tup = tup_new(2);
  158.     tup[1] = (char *) array_name;
  159.     tup[2] = (char *) dtup;
  160.     return tup;
  161. }
  162.  
  163. static int array_nelem(Node node)                            /*;array_nelem*/
  164. {
  165.     /*
  166.      * Given a node that is appropriate for an array type, determines the
  167.      * number of elements if known statically, returns OM otherwise.
  168.      */
  169.  
  170.     Symbol   node_name, type_name, index_sym;
  171.     Tuple     index_list, tup;
  172.     int        size, nk;
  173.     Node        nod2, lbd_node, ubd_node;
  174.     Fortup    ft1;
  175.     Const    lbd, ubd;
  176.  
  177.     /* the global (to this module) variable array_nelem_defined is set to
  178.      * FALSE if the SETL version of this procedure returns OM, TRUE otherwise
  179.      */
  180.     array_nelem_defined = TRUE; /* assume defined */
  181.     nk = N_KIND(node);
  182.     if (nk == as_subtype_indic) {
  183.         nk = (int) N_KIND((N_AST2(node) == OPT_NODE) ?
  184.           N_AST1(node) : N_AST2(node));
  185.         nod2 = N_AST2(node);
  186.     }
  187.     if (nk == as_string_ivalue) {
  188.         return tup_size((Tuple) N_VAL(node));
  189.     }
  190.     else if (nk == as_simple_name) {
  191.         node_name = N_UNQ(node);
  192.         if (NATURE(node_name) == na_type) {
  193.             array_nelem_defined = FALSE;
  194.             return 0;    /* always unconstrained */
  195.         }
  196.         else if ( NATURE(node_name) == na_subtype) {
  197.             type_name = node_name;
  198.         }
  199.         else { /* object */
  200.             type_name = N_TYPE(node);
  201.         }
  202.         tup        = SIGNATURE(type_name);
  203.         index_list = (Tuple) tup[1];
  204.         size       = 1;
  205.         FORTUP(index_sym  = (Symbol), index_list, ft1);
  206.             tup = SIGNATURE(index_sym);
  207.             lbd_node = (Node) tup[2];
  208.             ubd_node = (Node) tup[3];
  209.             lbd = get_ivalue(lbd_node);
  210.             ubd = get_ivalue(ubd_node);
  211.             if (lbd->const_kind != CONST_OM  && ubd->const_kind != CONST_OM) {
  212.                 if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
  213.                     return 0;
  214.                 else
  215.                     size *= get_ivalue_int(ubd_node)-get_ivalue_int(lbd_node)+1;
  216.             }
  217.             else{
  218.                 array_nelem_defined = FALSE;
  219.                 return 0;
  220.             }
  221.         ENDFORTUP(ft1);
  222.         return size;
  223.     }
  224. #ifdef TBSL
  225.     /* Wrong because the type_name is the base_type*/
  226.     else if (nk == as_array_aggregate || nk == as_array_ivalue)  {
  227.         type_name  = N_TYPE(node);
  228.         tup        = SIGNATURE(type_name);
  229.         index_list = (Tuple) tup[1];
  230.         size       = 1;
  231.         FORTUP(index_sym  = (Symbol), index_list, ft1);
  232.         tup = SIGNATURE(index_sym);
  233.         lbd_node = (Node) tup[2];
  234.         ubd_node = (Node) tup[3];
  235.         lbd = get_ivalue(lbd_node);
  236.         ubd = get_ivalue(ubd_node);
  237.         if (lbd->const_kind != CONST_OM  &&
  238.             ubd->const_kind != CONST_OM) {
  239.             if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node)) {
  240.                 return 0;
  241.             }
  242.             else {
  243.                 size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
  244.             }
  245.         }
  246.         else{
  247.             array_nelem_defined = FALSE;
  248.             return 0;
  249.         }
  250.         ENDFORTUP(ft1);
  251.         return size;
  252.     }
  253. #endif
  254.     else if (nk == as_range) {
  255.         lbd_node = N_AST1(nod2);
  256.         ubd_node = N_AST2(nod2);
  257.         size     = 1;
  258.         lbd = get_ivalue(lbd_node);
  259.         ubd = get_ivalue(ubd_node);
  260.         if (lbd->const_kind != CONST_OM  && ubd->const_kind != CONST_OM) {
  261.             if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
  262.                 return 0;
  263.             else
  264.                 size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
  265.         }
  266.         else{
  267.             array_nelem_defined = FALSE;
  268.             retu